home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Appls / sortmerge.f < prev    next >
Encoding:
FORTH Source  |  1988-08-19  |  3.8 KB  |  183 lines
  1. \ Sort Merge two files into a third.
  2. \
  3. \ This will change when two virtual
  4. \ files can be opened together. %Q
  5. \
  6. \ Author: Phil Burk
  7. \ Copyright 1988 Phil Burk
  8. \ All Rights Reserved.
  9.  
  10. ANEW TASK-SORTMERGE
  11.  
  12. 200 constant FH_MAX_CHARS
  13. :STRUCT FILEHEAD
  14.   long FH_FILEID
  15.   long FH_FILEBUF
  16.   long FH_LINESTART  ( %Q kludge to allow two virtual files )
  17.   fh_max_chars bytes FH_LINEBUF 
  18. ;struct
  19.  
  20. \ Holders for multiple names since they would conflict
  21. \ if left on the PAD.
  22. \ These are made large so they can also be used
  23. \ as pads for converting strings to uppercase.
  24. VARIABLE FILENAME1 256 allot
  25. VARIABLE FILENAME2 256 allot
  26.  
  27. filehead INFILEHEAD1
  28. filehead INFILEHEAD2
  29. variable OUTFILEID
  30.  
  31. : $FH.OPEN.VFILE  ( $name filehead -- if_ok )
  32.     >r
  33.     $fopen dup r@ ..! fh_fileid
  34.     IF r@ .. fh_filebuf openfv drop ( %Q )
  35.       true
  36.     ELSE false
  37.     THEN
  38.     rdrop
  39. ;
  40.  
  41. : FH.CLOSE.VFILE  ( filehead -- )
  42.     dup ..@ fh_fileid dup ( -- fh id id )
  43.     IF fclose
  44.        dup .. fh_filebuf closefvread
  45.        0 swap ..! fh_fileid
  46.     ELSE 2drop
  47.     THEN
  48. ;
  49.  
  50. : FH.READ.LINE ( filehead -- #chars )
  51.     >r
  52.     r@ ..@ fh_fileid
  53.     r@ .. fh_filebuf
  54.     r@ .. fh_linebuf 1+
  55.     fh_max_chars
  56.     r@ ..@ fh_linestart line-start !
  57.     readline  nip ( %Q )
  58.     dup r@ .. fh_linebuf c!
  59. \ ." Read: "    r@ .. fh_linebuf $type cr ?pause
  60.     line-start @ r@ ..! fh_linestart
  61.     rdrop
  62. ;
  63.  
  64. : FH.READ.FULL.LINE ( filehead -- #chars , skip blank lines )
  65.     BEGIN
  66.         dup fh.read.line ?dup
  67.     UNTIL nip
  68. ;
  69.  
  70. : SM.WRITE.LINE ( filehead -- )
  71.     outfileid @ 
  72.     swap .. fh_linebuf \ dup $type cr
  73.     count fwrite drop
  74.     outfileid @ $ 0A femit
  75. ;
  76.  
  77. VARIABLE SM-CASE-SENSITIVE
  78. sm-case-sensitive on
  79.  
  80. .NEED $CONVERT2UPPER
  81. : $CONVERT2UPPER  ( $string -- , convert in place )
  82.     count 0
  83.     DO i over + c@ dup
  84.        ascii a ascii z within?
  85.        IF  ascii a - ascii A +
  86.            i 2 pick + c!
  87.        ELSE drop
  88.        THEN
  89.     LOOP drop
  90. ;
  91. .THEN
  92.  
  93. : SM.COMPARE.1/2 ( -- true_if_1_bigger )
  94.     infilehead1 .. fh_linebuf
  95.     infilehead2 .. fh_linebuf
  96.     SM-CASE-SENSITIVE @
  97.     IF ( $line1 $line2 )
  98.         filename2 $move
  99.         filename1 $move
  100.         filename1 $convert2upper
  101.         filename2 $convert2upper
  102.         filename1 filename2
  103.     THEN
  104.     $- 0>
  105. ;
  106.  
  107. : SM.LOOP.FILE ( -- file_left )
  108.     BEGIN
  109.         infilehead2 infilehead1
  110.         sm.compare.1/2
  111.         IF swap
  112.         THEN
  113.         dup sm.write.line
  114.         fh.read.full.line 0< not
  115.     WHILE
  116.         drop
  117.     REPEAT  ( filehead with lines left )
  118. ;
  119.  
  120. : SM.COPY.FILE ( filehead -- )
  121.     BEGIN
  122.         dup fh.read.full.line 0< not
  123.     WHILE
  124.         dup sm.write.line
  125.     REPEAT
  126.     drop
  127. ;
  128.  
  129. : SM.PROCESS.FILE ( -- )
  130.     infilehead1 fh.read.full.line 0<
  131.     IF ." FILE1 empty!" cr
  132.     ELSE infilehead2 fh.read.full.line 0<
  133.         IF ." FILE2 empty!" cr
  134.         ELSE sm.loop.file
  135.             sm.copy.file
  136.         THEN
  137.     THEN
  138. ;
  139.  
  140. : $SM.OPEN.FILES ( $infile1 $infile2 $outfile -- if_ok )
  141.     new $fopen dup outfileid !
  142.     IF  infilehead2 $fh.open.vfile
  143.         IF  infilehead1 $fh.open.vfile
  144.             IF true
  145.             ELSE false
  146.             THEN
  147.         ELSE drop false
  148.         THEN
  149.     ELSE 2drop false
  150.     THEN
  151. ;
  152.  
  153. : SM.CLOSE.FILES  ( -- , close files if open )
  154.     infilehead1 fh.close.vfile
  155.     infilehead2 fh.close.vfile
  156.     outfileid @ ?dup
  157.     IF  fclose
  158.         0 outfileid !
  159.     THEN
  160. ;
  161.  
  162. : SM.USAGE  ( -- , print instructions )
  163.     cr ." SortMerge -  Written in JForth by Phil Burk" cr
  164.     cr ." USAGE:   sortmerge infile1 infile2 outfile" cr cr
  165.     ." The contents of infile1 and infile2 will be merged" cr
  166.     ." to outfile in sorted order.  Infile1 and infile2" cr
  167.     ." must be presorted!" cr
  168. ;
  169.  
  170. : $SORTMERGE ( $infile1 $infile2 $outfile -- )
  171.     $SM.open.files
  172.     IF SM.process.file
  173.     ELSE sm.usage
  174.     THEN
  175.     SM.close.files
  176. ;
  177.  
  178. : SORTMERGE ( <infile1> <infile2> <outfile> -- )
  179.     fileword filename1 $move filename1
  180.     fileword filename2 $move filename2
  181.     fileword $sortmerge
  182. ;
  183.